Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/pcl/sptmbr11.lha/clcs/debugger.lisp

Lisp/Scheme | 1990-12-06 | 5KB | 144 lines

;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-

(in-package "CONDITIONS")

(DEFVAR *DEBUG-LEVEL* 0)
(DEFVAR *DEBUG-ABORT* NIL)
(DEFVAR *DEBUG-CONTINUE* NIL)
(DEFVAR *DEBUG-CONDITION* NIL)
(DEFVAR *DEBUG-RESTARTS* NIL)
(DEFVAR *NUMBER-OF-DEBUG-RESTARTS* 0)
(DEFVAR *DEBUG-EVAL* 'EVAL)
(DEFVAR *DEBUG-PRINT* #'(LAMBDA (VALUES) (FORMAT T "~&~{~S~^,~%~}" VALUES)))

(DEFMACRO DEBUG-COMMAND                (X) `(GET ,X 'DEBUG-COMMAND))
(DEFMACRO DEBUG-COMMAND-ARGUMENT-COUNT (X) `(GET ,X 'DEBUG-COMMAND-ARGUMENT-COUNT))

(DEFMACRO DEFINE-DEBUG-COMMAND (NAME BVL &REST BODY)
  `(PROGN (SETF (DEBUG-COMMAND ',NAME) #'(LAMBDA ,BVL ,@BODY))
          (SETF (DEBUG-COMMAND-ARGUMENT-COUNT ',NAME) ,(LENGTH BVL))
          ',NAME))

(DEFUN READ-DEBUG-COMMAND ()
  (FORMAT T "~&Debug ~D> " *DEBUG-LEVEL*)
  (COND ((CHAR= (PEEK-CHAR T) #\:)
     (READ-CHAR) ;Eat the ":" so that ":1" reliably reads a number.
     (WITH-INPUT-FROM-STRING (STREAM (READ-LINE))
       (LET ((EOF (LIST NIL)))
         (DO ((FORM (LET ((*PACKAGE* (FIND-PACKAGE "KEYWORD")))
              (READ STREAM NIL EOF))
            (READ STREAM NIL EOF))
          (L '() (CONS FORM L)))
         ((EQ FORM EOF) (NREVERSE L))))))
    (T
     (LIST :EVAL (READ)))))

(DEFINE-DEBUG-COMMAND :EVAL (FORM)
  (FUNCALL *DEBUG-PRINT* (MULTIPLE-VALUE-LIST (FUNCALL *DEBUG-EVAL* FORM))))

(DEFINE-DEBUG-COMMAND :ABORT ()
  (IF *DEBUG-ABORT*
      (INVOKE-RESTART-INTERACTIVELY *DEBUG-ABORT*)
      (FORMAT T "~&There is no way to abort.~%")))

(DEFINE-DEBUG-COMMAND :CONTINUE ()
  (IF *DEBUG-CONTINUE*
      (INVOKE-RESTART-INTERACTIVELY *DEBUG-CONTINUE*)
      (FORMAT T "~&There is no way to continue.~%")))

(DEFINE-DEBUG-COMMAND :ERROR ()
  (FORMAT T "~&~A~%" *DEBUG-CONDITION*))

(DEFINE-DEBUG-COMMAND :HELP ()
  (FORMAT T "~&You are in a portable debugger.~
             ~%Type a debugger command or a form to evaluate.~
             ~%Commands are:~%")
  (SHOW-RESTARTS *DEBUG-RESTARTS* *NUMBER-OF-DEBUG-RESTARTS* 16)
  (FORMAT T "~& :EVAL form     Evaluate a form.~
             ~% :HELP          Show this text.~%")
  (IF *DEBUG-ABORT*    (FORMAT T "~& :ABORT         Exit by ABORT.~%"))
  (IF *DEBUG-CONTINUE* (FORMAT T "~& :CONTINUE      Exit by CONTINUE.~%"))
  (FORMAT T "~& :ERROR         Reprint error message.~%"))



(defvar *debug-command-prefix* ":")

(DEFUN SHOW-RESTARTS (&OPTIONAL (RESTARTS *DEBUG-RESTARTS*)
                      (MAX *NUMBER-OF-DEBUG-RESTARTS*)
                TARGET-COLUMN)
  (UNLESS MAX (SETQ MAX (LENGTH RESTARTS)))
  (WHEN RESTARTS
    (DO ((W (IF TARGET-COLUMN
        (- TARGET-COLUMN 3)
        (CEILING (LOG MAX 10))))
         (P RESTARTS (CDR P))
         (I 0 (1+ I)))
        ((OR (NOT P) (= I MAX)))
      (FORMAT T "~& ~A~A "
          *debug-command-prefix*
          (LET ((S (FORMAT NIL "~D" (+ I 1))))
        (WITH-OUTPUT-TO-STRING (STR)
          (FORMAT STR "~A" S)
          (DOTIMES (I (- W (LENGTH S)))
            (WRITE-CHAR #\Space STR)))))
      (IF (EQ (CAR P) *DEBUG-ABORT*) (FORMAT T "(Abort) "))
      (IF (EQ (CAR P) *DEBUG-CONTINUE*) (FORMAT T "(Continue) "))
      (FORMAT T "~A" (CAR P))
      (FORMAT T "~%"))))

(defvar *DEBUGGER-HOOK* nil)
(defvar *debugger-function* 'STANDARD-DEBUGGER)

(DEFUN INVOKE-DEBUGGER (&OPTIONAL (DATUM "Debug") &REST ARGUMENTS)
  (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'DEBUG)))
    (WHEN *DEBUGGER-HOOK*
      (LET ((HOOK *DEBUGGER-HOOK*)
        (*DEBUGGER-HOOK* NIL))
    (FUNCALL HOOK CONDITION HOOK)))
    (funcall *debugger-function* CONDITION)))

(DEFUN STANDARD-DEBUGGER (CONDITION)
  (LET* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*))
     (*DEBUG-RESTARTS* (COMPUTE-RESTARTS))
     (*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*))
     (*DEBUG-ABORT*    (FIND-RESTART 'ABORT))
     (*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE)))
                 (IF (OR (NOT *DEBUG-CONTINUE*)
                     (NOT (EQ *DEBUG-CONTINUE* C)))
                     C NIL))
                   (LET ((C (IF *DEBUG-RESTARTS*
                        (FIRST *DEBUG-RESTARTS*) NIL)))
                 (IF (NOT (EQ C *DEBUG-ABORT*)) C NIL))))
     (*DEBUG-CONDITION* CONDITION))
    (FORMAT T "~&~A~%" CONDITION)
    (SHOW-RESTARTS)
    (DO ((COMMAND (READ-DEBUG-COMMAND)
          (READ-DEBUG-COMMAND)))
    (NIL)
      (EXECUTE-DEBUGGER-COMMAND (CAR COMMAND) (CDR COMMAND) *DEBUG-LEVEL*))))

(DEFUN EXECUTE-DEBUGGER-COMMAND (CMD ARGS LEVEL)
  (WITH-SIMPLE-RESTART (ABORT "Return to debug level ~D." LEVEL)
    (COND ((NOT CMD))
      ((INTEGERP CMD)
       (COND ((AND (PLUSP CMD)
               (< CMD (+ *NUMBER-OF-DEBUG-RESTARTS* 1)))
          (LET ((RESTART (NTH (- CMD 1) *DEBUG-RESTARTS*)))
            (IF ARGS
            (APPLY #'INVOKE-RESTART RESTART (MAPCAR *DEBUG-EVAL* ARGS))
            (INVOKE-RESTART-INTERACTIVELY RESTART))))
         (T
          (FORMAT T "~&No such restart."))))
      (T
       (LET ((FN (DEBUG-COMMAND CMD)))
         (IF FN
         (COND ((NOT (= (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD)))
            (FORMAT T "~&Too ~:[few~;many~] arguments to ~A."
                (> (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD))
                CMD))
               (T
            (APPLY FN ARGS)))
         (FORMAT T "~&~S is not a debugger command.~%" CMD)))))))